home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / iconv8_l.arc / IDOL.ARC / IDOL.IOL < prev    next >
Encoding:
Text File  |  1990-03-19  |  23.7 KB  |  878 lines
  1. # @(#)idol.iol    6.30 (3/14/90)
  2. #
  3. # Idol: Icon-derived object language, version 6.30
  4. #
  5. # SYNOPSIS:
  6. #
  7. #   idol -install
  8. #   idol prog[.iol] ... [-x args ]
  9. #   prog
  10. #
  11. # FILES:
  12. #
  13. #   ./prog.iol                       : source file
  14. #   ./prog.icn                     : Icon code for non-classes in prog.iol
  15. #   ./idolcode.env/i_object.*      : Icon code for the universal object type
  16. #   ./idolcode.env/classname.icn   : Icon files are generated for each class
  17. #   ./idolcode.env/classname.u[12] : translated class files
  18. #   ./idolcode.env/classname       : class specification/interface
  19. #
  20. # SEE ALSO:
  21. #
  22. #   "Programming in Idol: An Object Primer"
  23. #   (U of Arizona Dept of CS Technical Report #90-10)
  24. #   serves as user's guide and reference manual for Idol
  25. #
  26. ### Global variables
  27. #
  28. # FILES  : fin = input (.iol) file, fout = output (.icn) file
  29. # CSETS  : alpha = identifier characters, nonalpha = everything else
  30. #          alphadot = identifiers + '.'
  31. #          white = whitespace, nonwhite = everything else
  32. # TAQUES : classes in this module
  33. # FLAGS  : comp if we should try to make an executable from args[1]
  34. #          strict if we should generate paranoic encapsulation protection
  35. #          loud if Idol should generate extra console messages
  36. #          exec if we should run the result after translation
  37. # LISTS  : links = names of external icon code to link to
  38. #          imports = names of external classes to import
  39. #          compiles = names of classes which need to be compiled
  40. #
  41. global fin,fout,fName,fLine,alpha,alphadot,white,nonwhite,nonalpha
  42. global classes,comp,exec,strict,links,imports,loud,compiles
  43.  
  44. #
  45. # initialize global variables
  46. #
  47. procedure initialize()
  48.   loud     := 1
  49.   comp     := 0
  50.   alpha    := &ucase ++ &lcase ++ '_' ++ &digits
  51.   nonalpha := &cset -- alpha
  52.   alphadot := alpha ++ '.'
  53.   white    := ' \t\014'
  54.   nonwhite := &cset -- white
  55.   classes  := taque()
  56.   links    := []
  57.   imports  := []
  58.   compiles := []
  59.   sysinitialize()
  60. end
  61.  
  62. procedure main(args)
  63.     initialize()
  64.     if *args = 0 then write("usage: idol files...")
  65.     else {
  66.       every i := 1 to *args do {
  67.     if \exec then next            # after -x, args are for execution
  68.     if args[i][1] == "-" then {
  69.       case map(args[i]) of {
  70.         "-c"   : {
  71.         sysok := &null
  72.         if comp = 0 then comp := -1        # don't make exe
  73.         }
  74.         "-install": return install(args[1:i+1])
  75.         "-quiet"  : loud := &null
  76.         "-strict" : strict := 1
  77.         "-s"      : sysok := &null
  78.         "-t"      : comp := -2                      # don't translate
  79.         "-version": return write("Idol version 6.30 of 3/14/90") & 0
  80.         "-x"      : exec := i
  81.       }
  82.         }
  83.         else if args[i][find(".cl",args[i]):0] := "" then push(imports,args[i])
  84.     else if args[i][find(".icn",args[i]):0] := "" then {
  85.       push(links,args[i])
  86.       icont(" -c "||args[i])
  87.     }
  88.     else if args[i][find(".u1",args[i]):0] := "" then push(links,args[i])
  89.     else if (args[i][find(".iol",args[i]):0] := "") |
  90.         tryopen(args[i]||".iol","r") then {
  91.       /exe := i
  92.       args[i][find(".iol",args[i]):0] := ""
  93.       /fout := sysopen(args[i]||".icn","w")
  94.       readinput(args[i]||".iol",1)
  95.         } else {
  96.           #
  97.           # let's go out and look for an appropriate .icn, .u1 or class file!
  98.           #
  99.       if tryopen(args[i]||".icn","r") then {
  100.         push(links,args[i])
  101.         icont(" -c "||args[i])
  102.       }
  103.       else if tryopen(args[i]||".u1") then push(links,args[i])
  104.       else if tryenvopen(args[i]) then push(imports,args[i])
  105.     }
  106.       }
  107.       gencode()
  108.       close(\fout)
  109.       if comp = 1 then makeexe(args,exe)
  110.     }
  111. end
  112.  
  113. #
  114. # gencode first generates specifications for all defined classes
  115. # It then imports those classes' specifications which it needs to
  116. # compute inheritance.  Finally, it writes out all classes' .icn files.
  117. #
  118. procedure gencode()
  119.   if \loud then write("Class import/export:")
  120.   #
  121.   # export specifications for each class
  122.   #
  123.   every cl := classes$foreach_t() do cl$writespec()
  124.   #
  125.   # import class specifications, transitively
  126.   #
  127.   repeat {
  128.     added := 0
  129.     every super:= ((classes$foreach_t())$foreachsuper() | !imports) do{
  130.       if /classes$lookup(super) then {
  131.     added := 1
  132.     fname := filename(super)
  133.     readinput(envpath(fname),2)
  134.     if /classes$lookup(super) then halt("can't import class '",super,"'")
  135.     writesublink(fname)
  136.       }
  137.     }
  138.     if added = 0 then break
  139.   }
  140.   #
  141.   # compute the transitive closure of the superclass graph
  142.   #
  143.   every (classes$foreach_t())$transitive_closure()
  144.   #
  145.   # generate output
  146.   #
  147.   if \loud then write("Generating code:")
  148.   writesublink("i_object")
  149.   every s := !links do writelink(s)
  150.   write(fout)
  151.   every out := $!classes do {
  152.     name := filename(out$name())
  153.     out$write()
  154.     put(compiles,name)
  155.     writesublink(name)
  156.   }
  157.   if *compiles>0 then cdicont(compiles)
  158. end
  159.  
  160. #
  161. # a class defining objects resulting from parsing lines of the form
  162. # tag name ( field1 , field2, ... )
  163. # If the constructor is given an argument, it is passed to self$read
  164. #
  165. class declaration(public name,fields,tag)
  166.   #
  167.   # parse a declaration string into its components
  168.   #
  169.   method read(decl)
  170.     decl ? {
  171.       # get my tag
  172.       tab(many(white))
  173.       if not (self.tag := =("procedure"|"class"|"method"|"record")) then
  174.     halt("declaration/read can't parse decl ",decl)
  175.       tab(many(white))
  176.       # get my name
  177.       if not (self.name := tab(many(alpha))) then
  178.     halt("declaration/read can't parse decl ",decl)
  179.       # get my fields
  180.       if not tab(find("(")+1) then
  181.       halt("declaration/read can't parse decl ",decl)
  182.       tab(many(white))
  183.       self.fields := classFields()
  184.       if not (self.fields$parse(tab(find(")")))) then
  185.     halt("declaration/read can't parse decl ",decl)
  186.     }
  187.   end
  188.  
  189.   #
  190.   # write a declaration; at the moment, only used by records
  191.   #
  192.   method write(f)
  193.      write(f,self$String())
  194.   end
  195.   #
  196.   # convert self to a string
  197.   #
  198.   method String()
  199.     return self.tag || " " || self.name || "(" || self.fields$String() || ")"
  200.   end
  201. initially
  202.   if \self.name then self$read(self.name)
  203. end
  204.  
  205. #
  206. # class body manages a list of strings holding the code for
  207. # procedures/methods/classes
  208. #
  209. class body(fn,ln,text)
  210.   method read()
  211.     self.fn    := fName
  212.     self.ln    := fLine
  213.     self.text  := []
  214.     while line := readln() do {
  215.       put(self.text, line)
  216.       line ? { tab(many(white)); if ="end" & &pos > *line then return }
  217.     }
  218.     halt("body/read: eof inside a procedure/method definition")
  219.   end
  220.   method write(f)
  221.     if \self.ln then write(f,"#line ",self.ln," \"",self.fn,"\"")
  222.     every write(f,$!self)
  223.   end
  224.   method delete()
  225.     return pull(self.text)
  226.   end
  227.   method size()
  228.     return (*\ (self.text)) | 0
  229.   end
  230.   method foreach()
  231.     if t := \self.text then suspend !self.text
  232.   end
  233. end
  234.  
  235. #
  236. # a class defining operations on classes
  237. #
  238. class class : declaration (supers,methods,text,imethods,ifields,glob)
  239.   # imethods and ifields are all lists of these:
  240.   record classident(class,ident)
  241.  
  242.   method read(line,phase)
  243.     self$declaration.read(line)
  244.     self.supers := idTaque(":")
  245.     self.supers$parse(line[find(":",line)+1:find("(",line)] | "")
  246.     self.methods:= taque()
  247.     self.text   := body()
  248.     while line  := readln() do {
  249.       line ? {
  250.     tab(many(white))
  251.     if ="initially" then {
  252.         self.text$read()
  253.         if phase=2 then return
  254.         self.text$delete()    # "end" appended manually during writing after
  255.                 # generation of the appropriate return value
  256.         return
  257.     } else if ="method" then {
  258.         decl := method(self.name)
  259.         decl$read(line,phase)
  260.         self.methods$insert(decl,decl$name())
  261.     } else if ="end" then {
  262.         # "end" is tossed here. see "initially" above
  263.         return
  264.     } else if ="procedure" then {
  265.         decl := Procedure("")
  266.         decl$read(line,phase)
  267.         /self.glob := []
  268.         put(self.glob,decl)
  269.     } else if ="global" then {
  270.         /self.glob := []
  271.         put(self.glob,Global(line))
  272.     } else if ="record" then {
  273.         /self.glob := []
  274.         put(self.glob,declaration(line))
  275.     } else if upto(nonwhite) then {
  276.         halt("class/read expected declaration on: ",line)
  277.     }
  278.       }
  279.     }
  280.     halt("class/read syntax error: eof inside a class definition")
  281.   end
  282.  
  283.   #
  284.   # Miscellaneous methods on classes
  285.   #
  286.   method has_initially()
  287.     return $*self.text > 0
  288.   end
  289.   method ispublic(fieldname)
  290.     if self.fields$ispublic(fieldname) then return fieldname
  291.   end
  292.   method foreachmethod()
  293.     suspend $!self.methods
  294.   end
  295.   method foreachsuper()
  296.     suspend $!self.supers
  297.   end
  298.   method foreachfield()
  299.     suspend $!self.fields
  300.   end
  301.   method transitive_closure()
  302.     count := $*self.supers
  303.     while count > 0 do {
  304.     added := taque()
  305.     every sc := $!self.supers do {
  306.       if /(super := classes$lookup(sc)) then
  307.         halt("class/transitive_closure: couldn't find superclass ",sc)
  308.       every supersuper := super$foreachsuper() do {
  309.         if / self.supers$lookup(supersuper) &
  310.          /added$lookup(supersuper) then {
  311.           added$insert(supersuper)
  312.         }
  313.       }
  314.     }
  315.     count := $*added
  316.     every self.supers$insert($!added)
  317.     }
  318.   end
  319.   #
  320.   # write the class declaration: if s is "class" write as a spec
  321.   # otherwise, write as a constructor
  322.   #
  323.   method writedecl(f,s)
  324.     writes(f, s," ",self.name)
  325.     if s=="class" & ( *(supers := self.supers$String()) > 0 ) then
  326.         writes(f," : ",supers)
  327.     writes(f,"(")
  328.     rv := self.fields$String(s)
  329.     if *rv > 0 then rv ||:= ","
  330.     if s~=="class" & \self.ifields then        # inherited fields
  331.       every l := !self.ifields do rv ||:= l.ident || ","
  332.     writes(f,rv[1:-1])
  333.     write(f,,")")
  334.   end
  335.   method writespec(f) # write the specification of a class
  336.     f := envopen(filename(self.name),"w")
  337.     self$writedecl(f,"class")
  338.     every ($!self.methods)$writedecl(f,"method")
  339.     if self$has_initially() then write(f,"initially")
  340.     write(f,"end")
  341.     close(f)
  342.   end
  343.  
  344.   #
  345.   # write out the Icon code for this class' explicit methods
  346.   # and its "nested global" declarations (procedures, records, etc.)
  347.   #
  348.   method writemethods()
  349.     f:= envopen(filename(self.name)||".icn","w")
  350.     every ($!self.methods)$write(f,self.name)
  351.  
  352.     if \self.glob & *self.glob>0 then {
  353.     write(f,"#\n# globals declared within the class\n#")
  354.     every i := 1 to *self.glob do (self.glob[i])$write(f,"")
  355.     }
  356.     close(f)
  357.   end
  358.  
  359.   #
  360.   # write - write an Icon implementation of a class to file f
  361.   #
  362.   method write()
  363.     f:= envopen(filename(self.name)||".icn","a")
  364.     #
  365.     # must have done inheritance computation to write things out
  366.     #
  367.     if /self.ifields then self$resolve()
  368.  
  369.     #
  370.     # write a record containing the state variables
  371.     #
  372.     writes(f,"record ",self.name,"_state(__state,__methods") # reserved fields
  373.     rv := ","
  374.     rv ||:= self.fields$idTaque.String()             # my fields
  375.     if rv[-1] ~== "," then rv ||:= ","
  376.     every s := (!self.ifields).ident do rv ||:= s || "," # inherited fields
  377.     write(f,rv[1:-1],")")
  378.  
  379.     #
  380.     # write a record containing the methods
  381.     #
  382.     writes(f,"record ",self.name,"_methods(")
  383.     rv := ""
  384.  
  385.     every s := ((($!self.methods)$name())    |    # my explicit methods
  386.         self.fields$foreachpublic()    |    # my implicit methods
  387.         (!self.imethods).ident        |    # my inherited methods
  388.         $!self.supers)                # super.method fields
  389.     do rv ||:= s || ","
  390.  
  391.     if *rv>0 then rv[-1] := ""            # trim trailling ,
  392.     write(f,rv,")")
  393.  
  394.     #
  395.     # write a global containing this classes' operation record
  396.     # along with declarations for all superclasses op records
  397.     #
  398.     writes(f,"global ",self.name,"__oprec")
  399.     every writes(f,", ", $!self.supers,"__oprec")
  400.     write(f)
  401.  
  402.     #
  403.     # write the constructor procedure.
  404.     # This is a long involved process starting with writing the declaration.
  405.     #
  406.     self$writedecl(f,"procedure")
  407.     write(f,"local self,clone")
  408.  
  409.     #
  410.     # initialize operation records for this and superclasses
  411.     #
  412.     write(f,"initial {\n",
  413.         "  if /",self.name,"__oprec then ",self.name,"initialize()")
  414.     if $*self.supers > 0 then
  415.     every (super <- $!self.supers) ~== self.name do
  416.         write(f,"  if /",super,"__oprec then ",super,"initialize()\n",
  417.             "  ",self.name,"__oprec.",super," := ", super,"__oprec")
  418.     write(f,"  }")
  419.  
  420.     #
  421.     # create self, initialize from constructor parameters
  422.     #
  423.     writes(f,"  self := ",self.name,"_state(&null,",self.name,"__oprec")
  424.     every writes(f,",",$!self.fields)
  425.     if \self.ifields then every writes(f,",",(!self.ifields).ident)
  426.     write(f,")\n  self.__state := self")
  427.  
  428.     #
  429.     # call my own initially section, if any
  430.     #
  431.     if $*self.text > 0 then write(f,"  ",self.name,"initially(self)")
  432.  
  433.     #
  434.     # call superclasses' initially sections
  435.     #
  436.     if $*self.supers > 0 then {
  437.     every (super <- $!self.supers) ~== self.name do {
  438.         if (classes$lookup(super))$has_initially() then {
  439.         if /madeclone := 1 then {
  440.             write(f,"  clone := ",self.name,"_state()\n",
  441.             "  clone.__state := clone\n",
  442.             "  clone.__methods := ",self.name,"__oprec")
  443.         }
  444.         write(f,"  # inherited initialization from class ",super)
  445.         write(f,"    every i := 2 to *self do clone[i] := self[i]\n",
  446.             "    ",super,"initially(clone)")
  447.         every l := !self.ifields do {
  448.             if l.class == super then
  449.             write(f,"    self.",l.ident," := clone.",l.ident)
  450.         }
  451.         }
  452.     }
  453.     }
  454.  
  455.     #
  456.     # return the pair that comprises the object:
  457.     # a pointer to the instance (__mystate), and
  458.     # a pointer to the class operation record
  459.     #
  460.     write(f,"  return idol_object(self,",self.name,"__oprec)\n",
  461.         "end\n")
  462.     
  463.     #
  464.     # write out class initializer procedure to initialize my operation record
  465.     #
  466.     write(f,"procedure ",self.name,"initialize()")
  467.     writes(f,"  initial ",self.name,"__oprec := ",self.name,"_methods")
  468.     rv := "("
  469.     every s := ($!self.methods)$name() do {        # explicit methods
  470.       if *rv>1 then rv ||:= ","
  471.       rv ||:= self.name||s
  472.     }
  473.     every me := self.fields$foreachpublic() do {    # implicit methods
  474.       if *rv>1 then rv ||:= ","            # (for public fields)
  475.       rv ||:= self.name||me
  476.     }
  477.     every l := !self.imethods do {            # inherited methods
  478.       if *rv>1 then rv ||:= ","
  479.       rv ||:= l.class||l.ident
  480.     }
  481.     write(f,rv,")\n","end")
  482.     #
  483.     # write out initially procedure, if any
  484.     #
  485.     if self$has_initially() then {
  486.     write(f,"procedure ",self.name,"initially(self)")
  487.     self.text$write(f)
  488.     write(f,"end")
  489.     }
  490.  
  491.     #
  492.     # write out implicit methods for public fields
  493.     #
  494.     every me := self.fields$foreachpublic() do {
  495.       write(f,"procedure ",self.name,me,"(self)")
  496.       if \strict then {
  497.     write(f,"  if type(self.",me,") == ",
  498.         "(\"list\"|\"table\"|\"set\"|\"record\") then\n",
  499.         "    runerr(501,\"idol: scalar type expected\")")
  500.     }
  501.       write(f,"  return .(self.",me,")")
  502.       write(f,"end")
  503.       write(f)
  504.     }
  505.  
  506.     close(f)
  507.  
  508.   end
  509.  
  510.   #
  511.   # resolve -- primary inheritance resolution utility
  512.   #
  513.   method resolve()
  514.     #
  515.     # these are lists of [class , ident] records
  516.     #
  517.     self.imethods := []
  518.     self.ifields := []
  519.     ipublics := []
  520.     addedfields := table()
  521.     addedmethods := table()
  522.     every sc := $!self.supers do {
  523.     if /(superclass := classes$lookup(sc)) then
  524.         halt("class/resolve: couldn't find superclass ",sc)
  525.     every superclassfield := superclass$foreachfield() do {
  526.         if /self.fields$lookup(superclassfield) &
  527.            /addedfields[superclassfield] then {
  528.         addedfields[superclassfield] := superclassfield
  529.         put ( self.ifields , classident(sc,superclassfield) )
  530.         if superclass$ispublic(superclassfield) then
  531.             put( ipublics, classident(sc,superclassfield) )
  532.         } else if \strict then {
  533.         warn("class/resolve: '",sc,"' field '",superclassfield,
  534.              "' is redeclared in subclass ",self.name)
  535.         }
  536.     }
  537.     every superclassmethod := (superclass$foreachmethod())$name() do {
  538.         if /self.methods$lookup(superclassmethod) &
  539.            /addedmethods[superclassmethod] then {
  540.         addedmethods[superclassmethod] := superclassmethod
  541.         put ( self.imethods, classident(sc,superclassmethod) )
  542.         }
  543.     }
  544.     every public := (!ipublics) do {
  545.         if public.class == sc then
  546.         put (self.imethods, classident(sc,public.ident))
  547.     }
  548.     }
  549.   end
  550. end
  551.  
  552. #
  553. # a class defining operations on methods and procedures
  554. #
  555. class method : declaration (class,text)
  556.   method read(line,phase)
  557.     self$declaration.read(line)
  558.     self.text := body()
  559.     if phase = 1 then
  560.       self.text$read()
  561.   end
  562.   method writedecl(f,s)
  563.     decl := self$String()
  564.     if s == "method" then decl[1:upto(white,decl)] := "method"
  565.     else {
  566.     decl[1:upto(white,decl)] := "procedure"
  567.     decl[upto(white,decl)] ||:= self.class
  568.     if *self.class ~= 0 then {
  569.         i := find("(",decl)
  570.         decl[i] ||:= "self" || (((decl[i+1] ~== ")"), ",") | "")
  571.     }
  572.     }
  573.     write(f,decl)
  574.   end
  575.   method write(f)
  576.     if self.name ~== "initially" then
  577.     self$writedecl(f,"procedure")
  578.     self.text$write(f)
  579.     self.text := &null            # after writing out text, forget it!
  580.   end
  581. end
  582.  
  583. #
  584. # A class for ordinary Icon global declarations
  585. #
  586. class Global(s)
  587.   method write(f)
  588.     write(f,self.s)
  589.   end
  590. end
  591.  
  592. #
  593. # a class corresponding to an Icon table, with special treatment of empties
  594. #
  595. class Table(t)
  596.   method size()
  597.     return (* \ self.t) | 0
  598.   end
  599.   method insert(x,key)
  600.     /self.t := table()
  601.     /key := x
  602.     if / (self.t[key]) := x then return
  603.   end
  604.   method lookup(key)
  605.     if t := \self.t then return t[key]
  606.     return
  607.   end
  608.   method foreach()
  609.     if t := \self.t then every suspend !self.t
  610.   end
  611. end
  612.  
  613. #
  614. # tabular queues (taques):
  615. # a class defining objects which maintain synchronized list and table reps
  616. # Well, what is really provided are loosely-coordinated list/tables
  617. #
  618. class taque : Table (l)
  619.   method insert(x,key)
  620.     /self.l := []
  621.     if self$Table.insert(x,key) then put(self.l,x)
  622.   end
  623.   method foreach()
  624.     if l := \self.l then every suspend !self.l
  625.   end
  626.   method insert_t(x,key)
  627.     self$Table.insert(x,key)
  628.   end
  629.   method foreach_t()
  630.     suspend self$Table.foreach()
  631.   end
  632. end
  633.  
  634. #
  635. # support for taques found as lists of ids separated by punctuation
  636. # constructor called with (separation char, source string)
  637. #
  638. class idTaque : taque(punc)
  639.   method parse(s)
  640.     s ? {
  641.       tab(many(white))
  642.       while name := tab(find(self.punc)) do {
  643.     self$insert(trim(name))
  644.     move(1)
  645.     tab(many(white))
  646.       }
  647.       if any(nonwhite) then self$insert(trim(tab(0)))
  648.     }
  649.     return
  650.   end
  651.   method String()
  652.     if /self.l then return ""
  653.     out := ""
  654.     every id := !self.l do out ||:= id||self.punc
  655.     return out[1:-1]
  656.   end
  657. end
  658.  
  659. #
  660. # parameter lists in which the final argument may have a trailing []
  661. #
  662. class argList : idTaque(public varg)
  663.   method insert(s)
  664.     if \self.varg then halt("variable arg must be final")
  665.     if i := find("[",s) then {
  666.       if not (j := find("]",s)) then halt("variable arg expected ]")
  667.       s[i : j+1] := ""
  668.       self.varg := s := trim(s)
  669.     }
  670.     self$idTaque.insert(s)
  671.   end
  672.   method String()
  673.     return self$idTaque.String() || ((\self.varg & "[]") | "")
  674.   end
  675. initially
  676.   self.punc := ","
  677. end
  678.  
  679. #
  680. # Idol class field lists in which fields may be preceded by a "public" keyword
  681. #
  682. class classFields : argList(publics)
  683.   method String(s)
  684.     if *(rv := self$argList.String()) = 0 then return ""
  685.     if /s | (s ~== "class") then return rv
  686.     if self$ispublic(self.l[1]) then rv := "public "||rv
  687.     every field:=self$foreachpublic() do rv[find(","||field,rv)] ||:= "public "
  688.     return rv
  689.   end
  690.   method foreachpublic()
  691.     if \self.publics then every suspend !self.publics
  692.   end
  693.   method ispublic(s)
  694.     if \self.publics then every suspend !self.publics == s
  695.   end
  696.   method insert(s)
  697.     s ? {
  698.       if ="public" & tab(many(white)) then {
  699.     s := tab(0)
  700.     /self.publics := []
  701.     put(self.publics,s)
  702.       }
  703.     }
  704.     self$argList.insert(s)
  705.   end
  706. initially
  707.   self.punc := ","
  708. end
  709.  
  710. #
  711. # tell whether the character following s is within a quote or not
  712. #
  713. procedure notquote(s)
  714.   quotes := 0
  715.   outs := ""
  716.   # this is a bug for people who write code like \"hello"...
  717.   s ? {
  718.     while outs ||:= tab(find("\\")+1) do { move(1) }
  719.     outs ||:= tab(0)
  720.   }
  721.   s := outs
  722.   outs := ""
  723.   s ? {
  724.     while outs ||:= tab(find("\""|"'")+1) do {
  725.     quotes +:= 1
  726.     if tab(find(outs[-1])) then {
  727.         quotes +:= 1
  728.         move(1)
  729.     }
  730.     }
  731.   }
  732.   if quotes % 2 = 0 then return
  733. end
  734.  
  735. #
  736. # filter the input translating $ references
  737. # (also eats comments and trims lines)
  738. #
  739. procedure readln()
  740.     count := 0
  741.     if line := read(fin) then {
  742.     fLine +:= 1
  743.     line[ 1(x<-find("#",line),notquote(line[1:x])) : 0] := ""
  744.     line := trim(line)
  745.     while ((x := find("$",line)) & notquote(line[1:x])) do {
  746.         z := line[x+1:0] ||" "         # " " is for bal()
  747.         if find(line[x+1],"!*@?") then { # Invocation operators $! $* $@ $?
  748.         z ? {
  749.             move(1)
  750.             tab(many(white))
  751.             if not (id := tab(many(alphadot))) then {
  752.               if not match("(") then halt("readline can't parse ",line)
  753.               if not (id := tab(&pos<bal())) then
  754.               halt("readline: cant bal ",&subject)
  755.             }
  756.             case line[x+1] of {
  757.             "@": Op := "activate"
  758.             "*": Op := "size"
  759.             "!": Op := "foreach"
  760.             "?": Op := "random"
  761.             default: halt("readline: unknown operator $",line[x+1])
  762.             }
  763.             count +:= 1
  764.             line[x:0] :=
  765.             "(__self"||count||" := "||id||").__methods."||
  766.             Op||"(__self"||count||".__state)"||tab(0)
  767.         }
  768.         } else {
  769.         reverse(line[1:x])||" " ? {
  770.             tab(many(white))
  771.             if not (id := reverse(tab(many(alphadot)))) then {
  772.               if not match(")") then halt("readline: can't parse")
  773.               if not (id := reverse(tab(&pos<bal(&cset,')','('))))
  774.             then halt("readline: can't bal ",&subject)
  775.             }
  776.             nummatched := &pos-1
  777.         }
  778.         if not (lp := find("(",z)) then halt("readline: expected '('")
  779.         if z[lp+1] ~== ")" then c:="," else c:=""
  780.         count +:= 1
  781.         line[x-nummatched : x+lp+1] :=
  782.           "(__self"||count||" := "||id||").__methods."||
  783.             z[1:lp+1]||"__self"||count||".__state"||c
  784.         }
  785.     }
  786.     return line
  787.  
  788.  
  789.     } else fail
  790. end
  791.  
  792. #
  793. # procedure to read a single Idol source file
  794. #
  795. procedure readinput(name,phase)
  796.     if \loud then write("\t",name)
  797.     fName := name
  798.     fLine := 0
  799.     fin   := sysopen(name,"r")
  800.     while line := readln() do {
  801.     line ? {
  802.         tab(many(white))
  803.         if ="class" then {
  804.         decl := class()
  805.         decl$read(line,phase)
  806.         if phase=1 then {
  807.             decl$writemethods()
  808.             classes$insert(decl,decl$name())
  809.         } else classes$insert_t(decl,decl$name())
  810.         }
  811.         else if ="procedure" then {
  812.         if comp = 0 then comp := 1
  813.         decl := method("")
  814.         decl$read(line,phase)
  815.         decl$write(fout,"")
  816.         }
  817.         else if ="record" then {
  818.         if comp = 0 then comp := 1
  819.         decl := declaration(line)
  820.         decl$write(fout,"")
  821.         }
  822.         else if ="global" then {
  823.         if comp = 0 then comp := 1
  824.         decl := Global(line)
  825.         decl$write(fout,"")
  826.         }
  827.         else if ="method" then {
  828.         halt("readinput: method outside class")
  829.         }
  830.     }
  831.     }
  832.     close(fin)
  833. end
  834.  
  835. #
  836. # error/warning/message handling
  837. #
  838. procedure halt(args[])
  839.   errsrc()
  840.   every writes(&errout,!args)
  841.   stop()
  842. end
  843.  
  844. procedure warn(args[])
  845.   errsrc()
  846.   every writes(&errout,!args)
  847.   write(&errout)
  848. end
  849.  
  850. procedure errsrc()
  851.   writes(&errout,"\"",\fName,"\", line ",\fLine,": Idol/")
  852. end
  853. #
  854. # System-independent, but system related routines
  855. #
  856. procedure tryopen(file,mode)
  857.   if f := open(file,mode) then return close(f)
  858. end
  859. procedure tryenvopen(file,mode)
  860.   return tryopen(envpath(file),mode)
  861. end
  862. procedure sysopen(file,mode)
  863.   if not (f := open(file,mode)) then
  864.       halt("Couldn't open file ",file," for mode ",mode)
  865.   return f
  866. end
  867. procedure envopen(file,mode)
  868.   return sysopen(envpath(file),mode)
  869. end
  870. procedure writelink(s)
  871.   write(fout,"link \"",s,"\"")
  872. end
  873. procedure icont(argstr,prefix)
  874. static s
  875. initial { s := (getenv("ICONT")|"icont") }
  876.   return mysystem(\prefix||s||argstr | s||argstr)
  877. end
  878.